;;########################################################################
;; workmap4.lsp
;; workmap/toolbar options, workmap help, delete icon-trees
;; Copyright (c) 1992-2002 by Forrest W. Young
;;########################################################################  


(defmeth workmap-proto :hide-toolbar ()
  (when (send self :toolbar)
        (send self :toolbar nil)
        (send self :redraw)))

(defmeth workmap-proto :show-toolbar ()
  (when (not (send self :toolbar))
        (send self :toolbar t)
        (send self :move-hidden-icons-down)
        (send self :redraw) ))

(defmeth workmap-proto :move-hidden-icons-down ()
  (let* ((n (send self :num-icons))
         (x (send self :x))
         (y (send self :y)))
    (when (and (> n 0) (< (min y) 32))
          (dotimes (i n)
                   (send self :move-icon-tree i 0 -32 x y nil)))))

(defmeth workmap-proto :workmap-options ()
  (send self :workmap-toolbar-options :workmap t))

(defmeth workmap-proto :edit-toolbar ()
  (send self :workmap-toolbar-options :workmap nil))

(defmeth workmap-proto :workmap-toolbar-options (&key workmap)
(setf *experimental* nil)
  (let* ((prefs nil)
         (num-buts)
         (num-icons (send *toolbar* :num-icons))
         (file nil)
         (oldbreak *breakenable*)
         (workmap-propor (send *vista* :workmap-proportion))
         (ratio (send edit-text-item-proto :new (format nil "~g" workmap-propor)
                      :text-length 4))
         (ratio-text (send text-item-proto :new
                      (format nil "WorkMap Proportion~%of Desktop Height")))
         
         (choice-text (send text-item-proto :new
               (string-upcase "When to Show Small Graph/Stats SubIcons:")))
         (button-text (format nil "Right-Click tool-bar buttons~%to change their function."))
         (spacer (send text-item-proto :new " "))
         (choice1 (send choice-item-proto :new 
                        (list "Never Show Graph/Stats Icons" "Show When Graph/Stats Created" "Always Show Graphs/Stats Icons") 
                     :value (if (send *workmap* :new-icon-style?) 2
                                (if (send *workmap* :show-icon-ears?) 1 0))))

         (icon-text (send text-item-proto :new 
                          (string-upcase "WorkMap Icon Title Options:")))
         (zz-text (send text-item-proto :new 
                          (string-upcase "Icon Layout:")))
         (icon-spacer (send text-item-proto :new " "))
         (zz-spacer (send text-item-proto :new " "))
         (box2 (send toggle-item-proto :new "Titles Have White Background?" 
                     :value (send self :icon-title-color)))
         (box3 (send toggle-item-proto :new "Titles Are Short?"  
                     :value (send self :short-icon-titles)))
         
         (box5 (send toggle-item-proto :new "Titles Include Data Version Numbers?"
                     :value (send self :show-extensions?)))
         (box4 (send toggle-item-proto :new "Zig-Zag Icon Layout (after restart)?"  
                     :value (send self :zig-zag) ))
         (tex2 (send text-item-proto :new 
                     (format nil "Maximum Number of Buttons?~%   (1 <= NMAX <= ~d)" num-icons)))
         (box6 (send toggle-item-proto :new
                     "Edit Button Actions?"
                     :value (send *toolbar* :enable-soft-buttons)))
         (box7 (send toggle-item-proto :new
                     "Save Changes?" :value t))
         (val1 (send edit-text-item-proto :new 
                     (format nil "~d" (send *toolbar* :num-icons-shown))
                     :text-length 2))
         (ok    (send modal-button-proto :new "OK"
                      :action #'(lambda ()
                  (if workmap
                      (list (send choice1 :value) (send box2 :value)
                            (send box3 :value) (send box4 :value) 
                            (send box5 :value) 
                            (send ratio :text)
                             )
                      (list (send box6 :value) (send box7 :value)
                            (send val1 :text))))))
         (cancel (send modal-button-proto :new "Cancel"))
         (dialog (send modal-dialog-proto :new
                       (list (list (if workmap
                                        (list 
                                         choice-text  
                                         (list spacer choice1)
                                         icon-text 
                                         (list icon-spacer
                                               (list box2 box3 box5))
                                         zz-text
                                         (list zz-spacer box4)
                                         
                                         )
                                       (list (list val1 tex2) box6 box7 button-text)))
                             (list ok cancel))
                       :default ok 
                       :title (if workmap "WorkMap Icon Options" 
                                          "Toolbar Button Options")))
         (prefs (send dialog :modal-dialog))
         (num-buts-str nil))
    (when prefs
          (cond 
            (workmap
             (setf prefs (select prefs (iseq 6)))
             (setf prefs (append prefs (list nil t
                         (format nil "~s" (send *toolbar* :num-icons-shown)))))
             (setf propor (read-from-string (select prefs 5))))
            (t
             (setf prefs (append (list 
                                 ; (not (send *workmap* :new-icon-style?)) 
                                  (if (send *workmap* :new-icon-style?) 2
                                      (if (send *workmap* :show-icon-ears?) 1 0))
                                  (send self :icon-title-color) 
                                  (send self :short-icon-titles)
                                  (send self :zig-zag)
                                  (send self :show-extensions?)
                                  (send *vista* :workmap-proportion)
                                  )
                                 prefs))
             (setf propor (select prefs 5))))
          (setf prefs (combine (remove (select prefs 5) prefs :test #'equal) propor))
          (setf num-buts-str (select prefs 7))
          (when num-buts-str
                (if (or (equal num-buts-str "")
                        (equal (remove-duplicates num-buts-str) " "))
                    (setf num-buts nil)
                    (if (not (integerp (read-from-string num-buts-str)))
                        (fatal-message "You must enter an integer value (or blank) for number of buttons shown.")
                        (setf num-buts (read-from-string num-buts-str))))
                (when num-buts
                      (if (< num-buts 1) (setf num-buts 1))
                      (if (>= num-buts num-icons) 
                          (setf num-buts num-icons))))
          (unless (<= 0 propor 1) (fatal-message "You must enter a proportion between 0 and 1 (inclusive)"))
         
          (setf file (open (strcat *prefs-dir-name* "workmap.lsp") 
                           :direction :output))
          (when *verbose* (print "Opening WorkMap from Dialog"))
          (setq *breakenable* nil)
          (unwind-protect
           ;(cond 
           ;  ((or (not (numberp (first prefs)))
           ;       (= (first prefs) 0))
           ;   ;(princ "(send *workmap* :show-icon-ears? nil)" file)
           ;   (send *workmap* :show-icon-ears? nil)
           ;   ;(princ "(send *workmap* :new-icon-style? nil)" file)
           ;   (send *workmap* :new-icon-style? nil))
           ;  ((= (first prefs) 2)
           ;   ;(princ "(send *workmap* :show-icon-ears? t)" file)
           ;   (send *workmap* :show-icon-ears? t)
           ;   ;(princ "(send *workmap* :new-icon-style? t)" file)
           ;   (send *workmap* :new-icon-style? t))
           ;  ((= (first prefs) 1)
           ;   ;(princ "(send *workmap* :show-icon-ears? t)" file)
           ;   (send *workmap* :show-icon-ears? t)
           ;   ;(princ "(send *workmap* :new-icon-style? nil)" file)
           ;   (send *workmap* :new-icon-style? nil))
           ;  )
           ;(terpri file)
           (cond ((not (third prefs))
                ;  (princ "(send *workmap* :icon-title-color (quote white))" file)
                  (send *workmap* :icon-title-color 'white))
             (t ;(princ "(send *workmap* :icon-title-color nil)" file)
                (send *workmap* :icon-title-color nil)))
           (terpri file)
           (cond ((third prefs) 
                  ;(princ "(send *workmap* :short-icon-titles t)" file)
                  (send *workmap* :short-icon-titles t))
             (t ;(princ "(send *workmap* :short-icon-titles nil)" file)
                (send *workmap* :short-icon-titles nil)))
           (terpri file)
           (cond ((fourth prefs) 
                 ; (princ "(send *workmap* :zig-zag t)" file)
                  (send *workmap* :zig-zag t))
             (t ;(princ "(send *workmap* :zig-zag nil)" file)
                (send *workmap* :zig-zag nil)))
           (terpri file)
           (cond ((fifth prefs)
                  ;(princ "(send *workmap* :show-extensions? t)" file)
                  (send *workmap* :show-extensions? t))
             (t ;(princ "(send *workmap* :show-extensions? nil)" file)
                (send *workmap* :show-extensions? nil)))
           (terpri file)
           (cond 
             ((sixth prefs)
              ;(princ "(send *toolbar* :enable-soft-buttons t)" file)
              (send *toolbar* :enable-soft-buttons t))
             (t ;(princ "(send *toolbar* :enable-soft-buttons nil)" file)
                (send *toolbar* :enable-soft-buttons nil)))
            (terpri file)
           ;(when (seventh prefs) 
           ;      (format file 
           ;          "(send *toolbar* :soft-button-titles (quote ~s ))"
           ;              (send *toolbar* :button-name-list)))
           ; (terpri file)
           (when (seventh prefs) 
                 ;(format file 
                 ;    "(send *toolbar* :soft-button-titles (quote ~s ))"
                 ;        (send *toolbar* :hard-button-name-list))
                 ;(terpri)
                 ;(format file
                 ;    "(send *vista* :previous-plugins (quote ~s))"
                 ;        (send *toolbar* :soft-button-titles))
                 ;(terpri)
                 ;(format file
                     "(send *vista* :analysis-menu-item-titles (quote ~s))"
                         (send *vista* :remove-dash-menu-items *analyze-menu*)))
           (terpri file)
           (when (ninth prefs)
                 ;(format file "(send *vista* :workmap-proportion ~d)~%"
                 ;        (ninth prefs))
                 (send *vista* :workmap-proportion (ninth prefs)))
           (when num-buts
                 ;(print `(send *workmap* :num-toolbar-buts 
                 ;              ,(send *workmap* :num-toolbar-buts)) file)
                 (send *toolbar* :change-num-tools-shown num-buts)
                 (setf *num-toolbar-buts-shown-at-startup* num-buts)
                 ;(print `(setf *num-toolbar-buts-shown-at-startup* ,num-buts) file))
           )
          (close file)
          (setq *breakenable* oldbreak)
          (send *workmap* :save-workmap-settings)
          (send *workmap* :redraw)
         ; (refresh-desktop)
          prefs)))

(defmeth workmap-proto :save-workmap-settings (&optional make-distribution)
  (if *workmap* 
      (save-workmap-settings make-distribution)
      (when *verbose* (format t "; workmap settings not saved. no workmap object"))))



(defmeth workmap-proto :show-help 
                   (icon &optional (flush t) title (add-help t) 
                         window (show (not *print-help-mode*)))
;fwy added window may 2000
"ARGS: icon &optional (flush t) title (add-help t) window
Shows help file associated with ICON, using the icon title as the file name. Flushes existing help window unless FLUSH is nil. Displays icon title as help window title unless TITLE is not nil. Adds string \"Help: \" in front of title when add-help is T. Displays  in WINDOW"
  (let* ((icon-title (send icon :title))
         (i)
         (fit nil)
         (help-file-name)
         (w (cond 
              ((and window (not show))
               (send *vista* :help-window-object nil)
               (help-window nil :show nil))
              (window (initial-help-window))
              ((not show)  (help-window nil :show nil))
              (t (send *vista* :help-window-object))))
        )
    (setf icon-title (remove-period icon-title))
    (setf help-file-name icon-title)
    (when (equal icon-title "Menu Help") 
          (setf icon-title "Menu Help On"))
    (when (and (> (length icon-title) 4)
               (equal ":" (subseq icon-title 4 5)))
          (setf help-file-name (strcat (subseq icon-title 0 4) "-" 
                                       (subseq icon-title 5 i))))
    (setf help-file-name (blanks-to-dashes help-file-name))
    (setf i (min (list 8 (length help-file-name))))
    (setf help-file-name 
          (strcat *help-dir-name* 
                  (string-downcase 
                   (subseq help-file-name 0 i)) ".hlp"))
    (if (not title) (setf title icon-title))
    (file-to-window help-file-name title w flush add-help fit show)
    ))

(defmeth workmap-proto :plot-help ()
  ;(send self :show-help self)
  (help-topics 0 3 t))

(defmeth workmap-proto :add-plot-help-item  ()
  (let* ((g self)
         (m (send menu-item-proto :new "WorkMap Help"
                  :action '(lambda () 
                      (send (send self :slot-value 'plot-obj) :plot-help))))
       ; (m2 (send menu-item-proto :new "GuideMap Help"
       ;           :action '(lambda ()
       ;              (file-to-window (strcat *help-dir-name* "guidemap.hlp") 
       ;                              "GuideMaps" *help-window*))))
         )
    (send m :add-slot 'plot-obj g)
    (send g :add-slot 'plot-help-menu m)
    (send *help-menu* :append-items m )
    (defmeth g :remove ()
      (send *help-menu* :delete-items 
            (send self :slot-value 'plot-help-menu))
      (call-next-method))
    (defun workmap-help ()
      (send m :do-action))
    (defmeth self :action
      (send self :do-click i j nil nil)  ;defun guidemap-help ()
    ;  (send m2 :do-action)
       )
    m))

;========================================================================
; delete icon tree methods
;========================================================================

(defun delete-object (&key (dialog t))
  (send *workmap* :delete-object :dialog dialog))

(defmeth iconmap-proto :delete-object (&key (dialog t))
  (let ((icli (send self :selected-icon)))
    (when icli (send self :delete-icon-tree icli t dialog))))

(defmeth iconmap-proto :delete-data (&key (dialog t))
  (send self :delete-icon-tree (1- (send current-object :icon-number)) t dialog))

(defmeth iconmap-proto :delete-model ()
  (send self :delete-icon-tree (1- (send current-object :icon-number))))

(defmeth iconmap-proto :delete-icon-tree 
            (icon-number &optional (hide-icons t) (dialog t))
  (let* ((ok (if dialog
                (ok-or-cancel-dialog 
                 (format nil "Delete the selected object~%and those associated with it?" t))
                t))
        (icon (select (send self :icon-list) icon-number))
        (icon-type (send icon :icon-type)))
    (when ok
          (send self :deleted-icon-number-list nil)
          (send self :delete-icons icon-number)
          (setf preceeding-icon
                (send self :break-incoming-connections
                      (send self :deleted-icon-number-list)))
          (send self :redraw)
          (if preceeding-icon
              (if (= 3 (send preceeding-icon :icon-type))
                  (setcm (send preceeding-icon :object))
                  (setcd (send preceeding-icon :object)))
              (send self :activate-new-object icon-type))
          )
        ))

(defmeth iconmap-proto :delete-icon-tree 
            (icon-number &optional (hide-icons t) (dialog t))
	(one-button-dialog "Delete Icon is not currently implemented" :first-button "Sorry"))

;(trace :connection-list :icon-list :icon-type 
;:deleted-icon-number-list :hide-icon :datasheet-object 
;:remove :spreadplots :disconnect-icon :break-incoming-connections-1)

(defmeth iconmap-proto :delete-icons 
              (current-icon-number &optional (hide-icons t))
"Deletes icons and out-going connection lines at a given tree level. Recursively moves down tree to next level down until bottom is reached. Updates incoming connections list for disconnected connections."

  (let* ((connection-list (send *workmap* :connection-list)) 
         (connected-icons (select connection-list current-icon-number))
         (current-icon (select (send *workmap* :icon-list)
                               current-icon-number))
         (current-icon-type (send current-icon :icon-type))
         (lower-icon) (result))
    (send self :deleted-icon-number-list 
          (add-element-to-list (send self :deleted-icon-number-list)
                               current-icon-number))
    (when hide-icons 
          (send self :hide-icon current-icon current-icon-number 
                current-icon-type)
          (when (not (= current-icon-type 2)) 
                (let ((sob (send current-icon :object)))
                  (when (send sob :datasheet-object)
                        (when (not (equal *desktop-datasheet*
                                          (send sob :datasheet-object) ))
                              (send (send sob :datasheet-object) :remove)))
                  (mapcar #'(lambda (spreadplot) (send spreadplot :remove))
                          (send sob :spreadplots)))))
    (when (first connected-icons)
          (dotimes (i (length connected-icons))
                   (setf result (send self :disconnect-icon
                                      current-icon-number connected-icons))
                   (setf next-icon (first result))
                   (setf connected-icons (second result))
                   (setf connected-icons 
                         (send self :break-incoming-connections-1 
                               current-icon-number next-icon connected-icons))
                   (when next-icon 
                         (send self :delete-icons next-icon hide-icons))
                   ))))

(defmeth iconmap-proto :hide-icon (icon icon-number icon-type)
  (setf (select (send self :deleted?) icon-number) t) 
  (send icon :deleted? t)
  (when (and (not (= icon-type 2)) (send *vista* :long-menus))
        (send self :disable-menu-item icon icon-type)))
#|
(defmeth iconmap-proto :remove-spreadplots (current-icon)
  (mapcar #'(lambda (spreadplot) (send spreadplot :remove))
          (send (send current-icon :object) :spreadplots)))
|#
(defmeth iconmap-proto :disconnect-icon 
  (icon-number connected-icons &optional connect-to-icon)
  (let* ((next-icon (first connected-icons)))
    (setf connected-icons (remove next-icon connected-icons))
    (when (not connected-icons) (setf connected-icons (list nil)))
    (setf (select (send self :connection-list) 
                  (if connect-to-icon connect-to-icon icon-number))
                  connected-icons)
    (list next-icon connected-icons)))

(defmeth iconmap-proto :break-incoming-connections-1 
                (icon-number next-icon connected-icons)
"Breaks incoming connections of icons below deleted icon"
  (let* ((connections-to-next 
          (select (send self :connections-to-me) next-icon))
         (remaining-connections-to-next 
          (remove icon-number connections-to-next)))
    (when (not remaining-connections-to-next)
          (setf remaining-connections-to-next (list nil)))
    (setf (select (send self :connections-to-me) next-icon)
          remaining-connections-to-next)
    connected-icons))

(defmeth iconmap-proto :break-incoming-connections (icon-number-list)
"Breaks incoming connections of icons above deleted icon"
  (let* ((incoming-list)(incoming)(preceeding-icon)
         (connection-list-for-incoming-icon))
    (dolist (i icon-number-list)
            (setf incoming-list (select (send self :connections-to-me) i))
            (dotimes (j (length incoming-list))
                     (setf incoming (select incoming-list j))
                     (when incoming
                           (setf connection-list-for-incoming-icon 
                                 (combine i (remove i
                                 (select (send self :connection-list)
                                         incoming))))
                           (send self :disconnect-icon i
                                 connection-list-for-incoming-icon
                                 incoming)
                           (setf incoming-icon 
                                 (select (send self :icon-list) incoming))
                           (setf preceeding-icon incoming-icon)
                           (when (= (send incoming-icon :icon-type) 2)
                                 (send self :hide-icon incoming-icon 
                                       incoming 2)
                                 (let* ((incoming-incoming (first 
                                         (select 
                                          (send self :connections-to-me) 
                                            incoming)))
                                        (in-in-con-list 
                                         (select (send self :connection-list)
                                                 incoming-incoming))
                                        (incoming-incoming-icon
                                         (select (send self :icon-list)
                                                 incoming-incoming)))
                                   (setf in-in-con-list 
                                         (combine incoming
                                                  (remove incoming in-in-con-list)))
                                   (send self :disconnect-icon 
                                         incoming-incoming in-in-con-list)
                                   (send self
                                       :break-incoming-connections-1
                                         incoming-incoming incoming nil)
                                   (setf preceeding-icon incoming-incoming-icon)))
                           )))
    preceeding-icon))
 

(defmeth iconmap-proto :disable-menu-item (icon icon-type)
  (let* ((stat-object (send icon :object))
         (menu-item-number (send stat-object :menu-length))
         (menu (if (= icon-type 3) *model-menu* *data-menu*))
         (menu-item (select (send menu :items) menu-item-number))
         )
    (send menu-item :enabled nil)))

(defmeth iconmap-proto :activate-new-object (icon-type)
  (let* ((icon-states (mapcar #'not (send self :deleted?)))
         (active-objects (select (send self :icon-list) (which icon-states)))
         (active-icon-types (mapcar #'(lambda (icon) (send icon :icon-type))
                                    active-objects))
         (first-same-type (position icon-type active-icon-types)))

    (when (not first-same-type)
          (cond
            ((= icon-type 1)
             (setf first-same-type (position 5 active-icon-types))
             (if (not first-same-type) 
                 (setf first-same-type (position 4 active-icon-types))))
            ((= icon-type 5)
             (setf first-same-type (position 1 active-icon-types))
             (if (not first-same-type) 
                 (setf first-same-type (position 4 active-icon-types))))
            ((= icon-type 4)
             (setf first-same-type (position 1 active-icon-types))
             (if (not first-same-type) 
                 (setf first-same-type (position 5 active-icon-types))))))
    (when (not first-same-type)
          (setf icon-type (first (remove 2 active-icon-types)))
          (setf first-same-type (position icon-type active-icon-types)))
    (when first-same-type 
          (cond
            ((or (= icon-type 1) (= icon-type 4) (= icon-type 5))
             (setcd (send (select active-objects first-same-type) :object)))
            ((= icon-type 3)
             (setcm (send (select active-objects first-same-type) :object)))
            ((fatal-message "Bad Icon type"))))
    (when (not active-objects)
          (send *obs-window* :clear)
          (send *var-window* :clear)
          (send *desktop-datasheet* :clear)
          )
    ))